perm filename WORDS.F4[MSS,LCS]1 blob sn#131222 filedate 1974-11-15 generic text, type T, neo UTF8
00100	C  SUBRS  WORDS, TYPE, SETLET, SETNUM 
00200	
00300		SUBROUTINE WORDS
00400		COMMON RJB,JA,RC,JC,RJC,RJD,RJE,RJF,RJG,X,IA,N
00500		1,Z,J,KN,ISET,Q(28) /PTR/PWDS(250),ITEM,LL,IS,IX
00600		COMMON/SCX/RHY(4),JALPHA(19),JD,L,Y,K,RX,RZ,RA,JE
00700		1/XRN/RN(4000) /ALF/INP(72),ML
00800		DATA KSLA/'/'/,IBLA/' '/
00900		1,JALPHA/',','-','.','=','(',')','+',
01000		1 '*',':',';','"',' ','$','%','&','@','#','<','>'/
01100	C   FOR ENTERING TEXT: 16, POS., STF., NT#., SIZE,  RHYTHM≠0
01200	C  RJF ≠0 CALLS NOTE NUM. SETUP
01300		CALL TYPE
01400		DO 31 KN=72,1,-1
01500	31	IF(INP(KN).NE.IBLA)GO TO 33
01600	C  KN=NUM OF CHARACTERS
01700	C  DON'T END WITH '*' IN 'LETTERS' INPUT!!!!!!!!
01800	C  , - . = ( ) + * : ; " BLANK --THIS IS ORDER PAST ALPHAB.
01900	C  $=UPPER CASE, %=LOWER, &=NON-ITALICS, @=ITALICS (48,49,50,51)
02000	C  #=RETURN TO PRIMITVE FONT
02100	33	L=1
02200		LL=1
02300		RA=RJB
02400	C   RA= ADDS UP TOTAL SPACE NEEDED
02500		RX=0
02600		RZ=0 
02700		ISET=IS
02800	C  FOR SETLET
02900	368	RN(IS+1)=16
03000		RN(IS+2)=RA
03100	C  NEXT IS A MAGIC NUMBER FOR SPACING LETTERS.
03200		Y=39.6*RSTJC
03300	C  RBL IS FOR CONTROL(NON-LETTERS, ETC.) CHARACTERS.
03400		RN(IS+3)=RJC
03500		RN(IS+4)=RJD
03600		CALL NOZERO(RJE)
03700		RN(IS+5)=RJE
03800	
03900		DO 364 JE=6,8
04000		Z=0
04100		DO 363 JD=1,4
04200	361	IA=INP(L)
04300		IF(IA.NE.KSLA)GO TO 365
04400	C  NEG. SPACE IS ENTERED IN P1 FOR EACH "FIRST" ITEM.
04500		JC=JD
04600		DO 367 KA=JE,8
04700		X=.990
04800		DO 366 K=JC,4
04900		Z=Z+X
05000	366	X=X*100.0
05100		RN(IS+KA)=Z
05200		JC=1
05300	367	Z=0
05400		L=L+1
05500	C  L=CHARACTER COUNTER
05600		GO TO 369
05700	365	DO 362 J=1,19
05800		IF(IA.NE.JALPHA(J))GO TO 362
05900		N=35+J
06000	C  FOUND A SPECIAL CHARACTER.
06100		GO TO 39
06200	362	CONTINUE
06300	38	N=10-('A'-INP(L))/536870912
06400	C   MAGIC NUMBER TO FIND LETTERS
06500		IF(N.LT.10)N=N+7
06600	39	L=L+1
06700	C  BLANK=99(=47)
06800		CALL SPACER(N,IFNT,RX,3.30537)
06900	C  NUM↑↑=19.7/5.96  FOR BASIC SPACE PER LETTER.
07000	C  GET SPACE FOR THIS LETTER.
07100		X=N
07200		IF(JD.EQ.2)X=X*100.
07300		IF(JD.EQ.4)X=X/100.
07400		IF(JD.EQ.1)X=X*10000.
07500	363	Z=Z+X
07600	364	RN(IS+JE)=Z
07700	369	RN(IS+9)=RX
07800		RN(IS+10)=RZ
07900	C  FOR CONTINUATION
08000		RA=RA+RX+5
08100		RX=0
08200		RN(IS)=7+RZ
08300		IS=IS+10+RZ
08400		LL=LL+1
08500		PWDS(ITEM+LL)=IS
08600	C  PUT IT IN THE PNTR ARRAY
08700		RZ=1.
08800		IF(IA.EQ.KSLA)RZ=0
08900		IF(L.LE.KN)GO TO 368
09000	
09100		INP(1)=0
09200	C   SO IT WON'T FIND A COMMAND IN THE MAIN PROG.
09300		IF(RJF.NE.0)CALL SETLET
09400		END
09500	C  PACKS 4 CHARS/WD, 3 WDS/ITEM.  ORDER=[, - . = ( )]  000000.00
09600	
09700		SUBROUTINE TYPE
09800		COMMON/ALF/INP(72),ML
09900		TYPE 8005
10000		ACCEPT 2114,INP
10100	2114	FORMAT(72A1)
10200	8005	FORMAT(' TYPE --'/)
10300		END
10600		SUBROUTINE SETLET
10800		COMMON/SCM/V(78),Y,LCNT,STAFF,JLIST(200),REND
10900		COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(14),M,K,J,X,A,B
11000		1 /FLM/RPOS(2,300) /PTR/PWDS(250),ITEM,L,I,IX /XRN/RN(4000)
11100		COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
11200		EQUIVALENCE (JF,JQ(4)),(ISET,RJQ(12))
11250		DATA DISP/1.4/
11300		M=1
11400		RPOS(1,1)=0
11500		DO 1 K=1,ITEM
11600		IF(FINDIT(K))GO TO 1
11700	C SKIPS NON-NOTES AND WRONG STAFF
11800		M=M+1
11900		RPOS(1,M)=RN(L+2)
12100	1	CONTINUE
12200		CALL SETNUM
12300		CALL SORT2(RPOS,M)
12400		K=2
12500	22	IF(RPOS(1,K).NE.RPOS(1,K-1))GO TO 2
12600		M=M-1
12700		DO 20 J=K,M
12800	20	RPOS(1,J)=RPOS(1,J+1)
12900	C  DELETES DOUBLE-STOPS - DOESN'T PUT NUM OVER 1ST NOTE.
13000		GO TO 22
13100	2	K=K+1
13200		IF(K.LT.M)GO TO 22
13300		DO 4 K=2,M
13400		JB=RHORZ(RPOS(1,K))
13500		CALL NOTWRT
13600		JF=JF+1
13700	4	IF(JF.EQ.10)JF=0
13800		CALL DPYOUT(3)
13900		CALL SETPOG(1)
14000		RPOS(1,M+1)=200
14100		J=1
14200		CALL TYPE
14300		REREAD F78F,V
14400		X=V(J)+1
14500	CC	M=1
14600	3	K=X
14700		A=RPOS(1,K)
14800		B=RPOS(1,K+1)
14900		RN(ISET+2)=A+(B-A)*(X-K)+DISP
14950	C  DISP IS DISPLACEMENT OF CURRENT LETTERS.
15000		IF(RN(ISET+4).NE.0)GO TO 5
15100		RN(ISET+4)=V(J+1)
15200		J=J+2
15300		GO TO 6
15400	C IF P4≠0 TYPE ONLY 1 # FOR EACH ITEM. ALL ITEMS WILL BE AT VRT PS OF P4
15500	C TYPE Nn, Vert pos/Nn, Vert pos/  OR  Nn/Nn/ (if P4≠0)
15600	5	J=J+1
15700	6	ISET=ISET+RN(ISET)+3
15800		X=V(J)+1
15900		IF(X.GT.1)GO TO 3
16000	C CAN'T PUT LETTER AT POS. 0 *********
16100		END
16200	
16300		SUBROUTINE SETNUM
16400		DIMENSION SU(320)
16500		COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
16600		COMMON/POSI/STF(8),JJB,POS/DPY/ST(4000),WDS(250),MEDIT,IGO
16700		EQUIVALENCE (JC,JQ(1)),(JF,JQ(4)),(RJE,RJQ(3)),(RJD,RJQ(2))
16800		1,(SU(1),ST(3600))
16900		CALL DPYSET(3,SU,320)
17000		CALL DPYBRT(6)
17100		JF=1
17400		POS=STF(JC+4)
17500		RJD=18.
17600		JA=5
17700		RJE=1
17800		END
17900